home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / gnusutil.el < prev    next >
Encoding:
Text File  |  1994-11-11  |  15.5 KB  |  413 lines
  1. ;; Additional utility for GNUS (automatic code conversion support)
  2. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  3. ;; This file is part of Mule (MULtilingual Enhancement of GNU Emacs).
  4.  
  5. ;; Mule is free software distributed in the form of patches to GNU Emacs.
  6. ;; You can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; Mule is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;;; This package enables GNUS to code convert automatically
  21. ;;; accoding to a coding-system specified for each news group.
  22. ;;; Please put the following line in your .emacs:
  23. ;;;    (setq gnus-Group-mode-hook 'gnusutil-initialize)
  24. ;;;    (setq gnus-group-mode-hook 'gnusutil-initialize)
  25. ;;;    ;(gnusutil-add-group "xxx.yyy.zzz" 'some-coding-system)
  26.  
  27. ;;; 93.6.7   created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
  28. ;;;    Modified from the original hz2gb.el for more generic use.
  29. ;;; 93.6.18  modified for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
  30. ;;;    Completely re-written for GNUS 3.14.4
  31. ;;; 93.7.12  modified for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
  32. ;;;    Add coding-system *fj* support.
  33. ;;; 93.7.13  modified for Mule Ver.0.9.8 by K.Sakai<ksakai@mtl.t.u-tokyo.ac.jp>
  34. ;;;    Modified for GNUS 3.15.
  35. ;;; 93.8.3   modified for Mule Ver.1.1 by K.Handa <handa@etl.go.jp>
  36. ;;;    Typo: gnusutil-Article-prepare-hook -> gnusutil-article-prepare-hook.
  37. ;;; 93.9.28  modified for Mule Ver.1.1 by K.Handa <handa@etl.go.jp>
  38. ;;;    fj-valid-esc-seq fixed.
  39. ;;; 93.11.18 modified for Mule Ver.1.1 by K.Handa <handa@etl.go.jp>
  40. ;;;    Coding-system for posting is set dynamically from Newsgroup:.
  41. ;;; 93.11.19 modified for Mule Ver.1.1 by Y.Kawabe <kawabe@sra.co.jp>
  42. ;;;    Type in gnusutil-toggle-article-format fixed.
  43. ;;; 93.12.11 modified for Mule Ver.1.1
  44. ;;;                by Y.Kanazawa <kanazawa@flab.fujitsu.co.jp>
  45. ;;;    gnusutil-add-hook should have append option for several hooks.
  46. ;;; 94.6.17  modified for Mule Ver.2.0 by K.Handa <handa@etl.go.jp>
  47. ;;;    Should not convert CRLF to LF.
  48. ;;; 94.6.21  modified for Mule Ver.2.0 by K.Handa <handa@etl.go.jp>
  49. ;;;    In some case, gnus-current-article is nil.
  50. ;;; 94.6.28  modified for Mule Ver.2.0 by K.Handa <handa@etl.go.jp>
  51. ;;;    gnusutil-add-hook -> add-hook (of Emacs19).
  52.  
  53. (require 'gnus)
  54.  
  55. (defconst gnusutil-version "1.8")
  56.  
  57. (defvar gnusutil-news-groups nil
  58.   "Assoc list of news groups in which special encoding is used.
  59. Each element is a list of news-group name (regular expression)
  60. and cons of coding-systems for read and write.")
  61.  
  62. ;;;###autoload
  63. (defun gnusutil-add-group (name coding-system)
  64.   "Specify that news group NAME is encoded in CODING-SYSTEM.
  65. Subject and article buffers are automatically converted appropriately.
  66. If CODING-SYSTEM is cons, the car/cdr part is regarded as coding-system
  67. for read/write respectively."
  68.   (if (not (consp coding-system))
  69.       (setq coding-system (cons coding-system coding-system)))
  70.   (setq name (concat "^" (regexp-quote name)))
  71.   (let ((group (assoc name gnusutil-news-groups)))
  72.     (if group
  73.     (rplacd group coding-system)
  74.       (setq gnusutil-news-groups
  75.         (cons (cons name coding-system) gnusutil-news-groups)))))
  76.  
  77. (defun gnusutil-get-coding-system (name)
  78.   "Return the coding-system for news group NAME."
  79.   (let ((groups gnusutil-news-groups)
  80.     (len -1)
  81.     coding-system)
  82.     (while groups
  83.       (if (and (string-match (car (car groups)) name)
  84.            (= (match-beginning 0) 0) ;93.11.18 by K.Handa
  85.            (> (match-end 0) len))
  86.       (setq len (match-end 0)
  87.         coding-system (cdr (car groups))))
  88.       (setq groups (cdr groups)))
  89.     coding-system))
  90.  
  91. (defvar gnusutil-summary-encoded nil
  92.   "A flag to indicate if subject buffer is encoded or not. (obsolete)")
  93. (defvar gnusutil-article-encoded nil
  94.   "A flag to indicate if article buffer is encoded or not.")
  95. (defvar gnusutil-read-coding-system nil
  96.   "Coding-system for reading articles of the current news group.")
  97. (defvar gnusutil-subject nil)
  98. (defvar gnusutil-encoded-subject nil)
  99. (defvar gnusutil-original-subject nil)
  100. (defvar gnusutil-article-mode-line-leader nil)
  101.  
  102. (defun gnusutil-code-convert1 (start end coding-system encoding)
  103.   (if (< start end)
  104.       (save-excursion
  105.        (if encoding
  106.        (code-convert start end coding-system *internal*)
  107.      (code-convert start end *internal* coding-system)))))
  108.  
  109. (defun gnusutil-code-convert (coding-system encoding)
  110.   "Convert the current buffer while keeping (window-start) and (point)."
  111.   (if coding-system
  112.       (let ((win (get-buffer-window (current-buffer))))
  113.     (if win
  114.         ;; We should keep (point) and (window-start).
  115.         (save-window-excursion
  116.           (select-window win)
  117.           (if encoding
  118.           ;; Simple way to assure point is on valid character boundary.
  119.           (beginning-of-line))
  120.           (gnusutil-code-convert1 (point-min) (window-start)
  121.                       coding-system encoding)
  122.           (gnusutil-code-convert1 (window-start) (point)
  123.                       coding-system encoding)
  124.           (gnusutil-code-convert1 (point) (point-max)
  125.                       coding-system encoding)
  126.           (if (not (pos-visible-in-window-p))
  127.           ;; point went out of window, move to the bottom of window.
  128.           (move-to-window-line -1)))
  129.       ;; No window for the buffer,
  130.       ;; no need to worry about (point) nor (windos-start).
  131.       (gnusutil-code-convert1 (point-min) (point-max)
  132.                   coding-system encoding))
  133.     )))
  134.  
  135. (defun gnusutil-truncate-subject (subject maxclm &optional coding-system)
  136.   "Truncate SUBJECT to fit in COLUMN width.
  137. Also convert \"%\" to \"%%\" to escape from %-constructs in mode-line.
  138. If optional third arg CODING-SYSTEM is non-nil,
  139.  SUBJECT is converted to the original."
  140.   (let ((len (string-width subject))
  141.     (buf (get-buffer-create " *gnusutil-work-buf*"))
  142.      clm)
  143.     (save-excursion
  144.       (set-buffer buf)
  145.       (setq mc-flag (not coding-system))
  146.       (erase-buffer)
  147.       (insert subject)
  148.       (if coding-system
  149.       (code-convert (point-min) (point-max) *internal* coding-system))
  150.       (goto-char (point-min))
  151.       (end-of-line)
  152.       (setq clm (current-column))
  153.       (if (< clm maxclm)
  154.       ;; insert padding spaces
  155.       (insert-char ?  (- maxclm clm))
  156.     (if (> clm maxclm)
  157.         ;; subject too long
  158.         (progn
  159.           (move-to-column maxclm)
  160.           (forward-char -1)
  161.           (insert-char ?. (- maxclm (current-column))))))
  162.       (delete-region (point) (point-max))
  163.       ;; convert % -> %%
  164.       (goto-char (point-min))
  165.       (while (search-forward "%" nil t)
  166.     (insert ?%))
  167.       (buffer-string))))
  168.  
  169. (defconst gnusutil-article-mode-line
  170.   '("GNUS: "
  171.     gnusutil-article-mode-line-leader
  172.     (gnusutil-article-encoded
  173.      gnusutil-encoded-subject gnusutil-original-subject))
  174.   "mode-line-buffer-identification for *Article* buffer.")
  175.  
  176. (defun gnusutil-article-set-mode-line ()
  177.   "Set Article mode line string. (revised by 'gnusutil')"
  178.   ;; At first, prepare leader ...
  179.   (setq gnusutil-article-mode-line-leader
  180.     (format "%s/%s " gnus-newsgroup-name gnus-current-article))
  181.   ;; then, prepare subject ...
  182.   (let* ((maxlen 17))            ;Maximum subject length
  183.     ;; 'gnusutil-subject' is set in gnusutil-article-prepare-hook
  184.     (if (null gnusutil-subject)
  185.     ;; No subject, just make padding string
  186.     (setq gnusutil-original-subject (make-string maxlen ? )
  187.           gnusutil-encoded-subject gnusutil-original-subject)
  188.       ;; Article selected and has subject.  Now modify it for mode-line.
  189.       ;; The subject has already encoded. 
  190.       (setq gnusutil-encoded-subject
  191.         (gnusutil-truncate-subject gnusutil-subject maxlen))
  192.       ;; Prepare original subject.
  193.       (setq gnusutil-original-subject
  194.         (if gnusutil-read-coding-system
  195.         (gnusutil-truncate-subject gnusutil-subject maxlen
  196.                        gnusutil-read-coding-system)
  197.           gnusutil-encoded-subject))))
  198.   (setq mode-line-buffer-identification gnusutil-article-mode-line)
  199.   (set-buffer-modified-p t))
  200.  
  201. (defun gnusutil-retrieve-headers (arg)
  202.   ;; Replacement for gnus-retrieve-headers.
  203.   ;; I couldn't find a hook to do this work.
  204.   (let* ((file-coding-system-for-read *noconv*)
  205.      (headers (gnusutil-retrieve-headers-orig arg))
  206.      (coding-system (gnusutil-get-coding-system gnus-newsgroup-name)))
  207.     ;; At first, set coding-system for the current group.
  208.     (setq gnusutil-read-coding-system
  209.       (if (and coding-system (coding-system-p (car coding-system)))
  210.           (car coding-system)))
  211.     ;; Try to encode subjects of the current group.
  212.     (if gnusutil-read-coding-system
  213.     (mapcar
  214.      '(lambda (header)        ; Don't compile me!
  215.         (nntp-set-header-subject
  216.          header
  217.          (code-convert-string (nntp-header-subject header)
  218.                   gnusutil-read-coding-system *internal*)))
  219.      headers))
  220.     headers
  221.     ))
  222.  
  223. (defun gnusutil-request-article (arg)
  224.   ;; Replacement for gnus-request-article
  225.   ;; I couldn't find a hook to do this work.
  226.   (let ((file-coding-system-for-read *noconv*))
  227.     (gnusutil-request-article-orig arg)))
  228.  
  229. (defun gnusutil-Open-server-hook ()
  230.   ;; Don't convert code while reading from files.
  231.   (fset 'gnusutil-retrieve-headers-orig
  232.     (symbol-function 'gnus-retrieve-headers))
  233.   (fset 'gnus-retrieve-headers
  234.     (symbol-function 'gnusutil-retrieve-headers))
  235.   (fset 'gnusutil-request-article-orig
  236.     (symbol-function 'gnus-request-article))
  237.   (fset 'gnus-request-article
  238.     (symbol-function 'gnusutil-request-article))
  239.   )
  240.  
  241. (defun gnusutil-Select-group-hook ()
  242.   ;; At first, get coding-system for the current group.
  243.   (let ((coding-system (gnusutil-get-coding-system gnus-newsgroup-name)))
  244.     (setq gnusutil-read-coding-system
  245.       (if (and coding-system (coding-system-p (car coding-system)))
  246.           (car coding-system))))
  247.   ;; Then, try to encode subjects of the current group.
  248.   (if gnusutil-read-coding-system
  249.       (mapcar
  250.        '(lambda (header)        ; Don't compile me!
  251.       (nntp-set-header-subject
  252.        header
  253.        (code-convert-string (nntp-header-subject header)
  254.                 gnusutil-read-coding-system *internal*)))
  255.        gnus-newsgroup-headers)))
  256.  
  257. (defun gnusutil-article-prepare-hook ()
  258.   (setq gnusutil-subject
  259.     (if gnus-current-headers
  260.         (eval '(nntp-header-subject gnus-current-headers))))
  261.   (gnusutil-code-convert gnusutil-read-coding-system t)
  262.   (setq gnusutil-article-encoded t))
  263.  
  264. ;;I gave up toggling encode of Subject because it requires too dirty code.
  265. ;;(defun gnusutil-toggle-summary-format ()
  266. ;;  (interactive)
  267. ;;  (let (buffer-read-only)
  268. ;;    (setq gnusutil-summary-encoded (not gnusutil-summary-encoded))
  269. ;;    (gnusutil-code-convert gnusutil-read-coding-system
  270. ;;               gnusutil-summary-encoded)
  271. ;;    (set-buffer-modified-p t)))
  272.  
  273. (defun gnusutil-toggle-article-format ()
  274.   "Toggle encoding of *Article* buffer."
  275.   (interactive)
  276.   (let ((curbuf (current-buffer))
  277.     (buf (if (boundp 'gnus-article-buffer) ;93.11.19 by Y.Kawabe
  278.          (get-buffer gnus-article-buffer)
  279.            (get-buffer gnus-Article-buffer))))
  280.     (if (and gnusutil-read-coding-system buf)
  281.     (progn
  282.       (set-buffer buf)
  283.       (let ((modif (buffer-modified-p))
  284.         buffer-read-only)
  285.         (setq gnusutil-article-encoded (not gnusutil-article-encoded))
  286.         (gnusutil-code-convert gnusutil-read-coding-system
  287.                    gnusutil-article-encoded)
  288.         (set-buffer-modified-p modif))
  289.       (set-buffer curbuf)))))
  290.  
  291. (defun gnusutil-inews-article-hook ()
  292.   (let ((ng (mail-fetch-field "newsgroups")))
  293.     (if ng
  294.     (let ((coding-system (cdr (gnusutil-get-coding-system ng))))
  295.       (if coding-system
  296.           (gnusutil-code-convert coding-system nil))))))
  297.  
  298. (defvar gnusutil-initialize-hook nil
  299.   "A hook function called just after settings of gnusutil are done.")
  300.  
  301. ;;;###autoload
  302. (defun gnusutil-initialize ()
  303.   "Do several settings for GNUS to enable automatic code conversion."
  304.   ;; Communicate with nntp daemon without any code conversion
  305.   (define-service-coding-system gnus-nntp-service nil *noconv*)
  306.   ;; Convenient key definitions
  307.   ;(define-key gnus-summary-mode-map "Z" 'gnusutil-toggle-summary-format)
  308.   (if (boundp 'gnus-summary-mode-map)
  309.       (define-key gnus-summary-mode-map "z" 'gnusutil-toggle-article-format)
  310.     (define-key gnus-Subject-mode-map "z" 'gnusutil-toggle-article-format))
  311.   ;; Better function definition
  312.   (if (fboundp 'gnus-article-set-mode-line)
  313.       (fset 'gnus-article-set-mode-line
  314.         (symbol-function 'gnusutil-article-set-mode-line))
  315.     (fset 'gnus-Article-set-mode-line
  316.       (symbol-function 'gnusutil-article-set-mode-line)))
  317.   ;; Hook definition
  318.   (if (boundp 'gnus-open-server-hook)
  319.       (progn
  320.     (add-hook 'gnus-open-server-hook
  321.           'gnusutil-Open-server-hook)
  322.     (add-hook 'gnus-article-prepare-hook
  323.           'gnusutil-article-prepare-hook)
  324.     ;; Use append mode to execute gnusutil-inews-article-hook last.
  325.     (add-hook 'gnus-inews-article-hook
  326.           'gnusutil-inews-article-hook 'append))
  327.     (add-hook 'gnus-Open-server-hook
  328.           'gnusutil-Open-server-hook)
  329.     (add-hook 'gnus-Article-prepare-hook
  330.           'gnusutil-article-prepare-hook)
  331.     (add-hook 'gnus-Inews-article-hook
  332.           'gnusutil-inews-article-hook 'append))
  333.   ;; All setting are done.  Now call hook.
  334.   (run-hooks 'gnusutil-initialize-hook))
  335.  
  336. (gnusutil-add-group "" '*junet*unix) ;; default coding system
  337. (gnusutil-add-group "alt" '*noconv*)
  338. (gnusutil-add-group "comp" '*noconv*)
  339. (gnusutil-add-group "gnu" '*noconv*)
  340. (gnusutil-add-group "rec" '*noconv*)
  341. (gnusutil-add-group "sci" '*noconv*)
  342. (gnusutil-add-group "soc" '*noconv*)
  343. (gnusutil-add-group "alt.chinese.text" '*hz*)
  344. (gnusutil-add-group "alt.hk" '*hz*)
  345. (gnusutil-add-group "alt.chinese.text.big5" '*big5-eten*unix)
  346. (gnusutil-add-group "soc.culture.vietnamese" '(nil *viqr*))
  347.  
  348. ;; Special treatment for fj.editor.mule
  349. (gnusutil-add-group "fj.editor.mule" '*fj*)
  350.  
  351. (make-coding-system
  352.  '*fj* 0
  353.  ?F "Coding-system used in fj.editor.mule."
  354.  nil)
  355.  
  356. (defconst fj-valid-esc-seq        ; 93.9.28 by K.Handa
  357.   "\\([NO]\\|\\$\\([@AB]\\|\([CD]\\)\\|[(*][BJ]\\|\\.[AFH]\\)")
  358.  
  359. (defconst fj-printable-equal (format "=%2x" ?=))
  360. (defconst fj-printable-esc (format "=%2x" ?\e))
  361. (defconst fj-mule-special-heading
  362.   "### Mule special encoding for fj.editor.mule ###\n")
  363.  
  364. (defun fj-pre-write-conversion (from to)
  365.   (goto-char from)
  366.   (search-forward "\n\n" nil t)
  367.   (save-restriction
  368.     (narrow-to-region (point) to)
  369.     (code-convert-region (point-min) (point-max) *internal* *iso-2022-ss2-7*)
  370.     (goto-char (point-min))
  371.     (let (invalid-sequence-found)
  372.       (while (and (not invalid-sequence-found)
  373.           (search-forward "\e" nil t))
  374.     (setq invalid-sequence-found
  375.           (not (looking-at fj-valid-esc-seq))))
  376.       (if invalid-sequence-found
  377.       (progn
  378.         (goto-char (point-min))
  379.         (insert fj-mule-special-heading)
  380.         (while (search-forward "=" nil t)
  381.           (replace-match fj-printable-equal t t))
  382.         (goto-char (point-min))
  383.         (while (search-forward "\e" nil t)
  384.           (if (looking-at fj-valid-esc-seq)
  385.           nil
  386.         (delete-char -1)
  387.         (insert fj-printable-esc))))))))
  388.  
  389. (defun fj-post-read-conversion (from to)
  390.   (save-excursion
  391.     (goto-char from)
  392.     (search-forward "\n\n" nil t)
  393.     (save-restriction
  394.       (narrow-to-region (point) to)
  395.       (if (looking-at (format "^%s" (regexp-quote fj-mule-special-heading)))
  396.       (progn
  397.         (goto-char (point-min))
  398.         (while (search-forward fj-printable-esc nil t)
  399.           (replace-match "\e" t t))
  400.         (goto-char (point-min))
  401.         (while (search-forward fj-printable-equal nil t)
  402.           (replace-match "=" t t))))
  403.       (code-convert-region (point-min) (point-max)
  404.                *iso-2022-ss2-7* *internal*))))
  405.  
  406. (put *fj* 'post-read-conversion 'fj-post-read-conversion)
  407. (put *fj* 'pre-write-conversion 'fj-pre-write-conversion)
  408.  
  409. (defvar gnus-Group-mode-hook 'gnusutil-initialize)
  410. (defvar gnus-group-mode-hook 'gnusutil-initialize)
  411.  
  412. (provide 'gnusutil)
  413.